home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / net.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  4.7 KB  |  131 lines
  1. ;;; -*- Mode: Lisp; Base: 10.; Package: BOXER -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;Send mail
  17. (defboxer-function mail ((datafy to) (datafy msg))
  18.   (let ((header-box (car (evrow-items (car (evbox-rows to)))))
  19.     (message-box (car (evrow-items (car (evbox-rows msg))))))
  20.     (with-output-to-string (confirmation)
  21.       (mail-text-string
  22.     (send (send header-box :row-at-row-no 0) :text-string)
  23.     (or (tell (tell header-box :row-at-row-no 1) :text-string) " ")    ;subject
  24.     (tell message-box :text-string))
  25.       confirmation)))
  26.  
  27. ;;Read Mail function
  28. ;Maybe we can use some zmail flavors for this.  This thing just reads twenex mail files.
  29. ;We really need to snarf something from Zmail to do all this.
  30.  
  31. (defboxer-function read-mail ()
  32.   (read-mail-from-file-to-boxes (user-mail-file)))
  33.  
  34. (defboxer-function read-mail-from-file ((portify filename))
  35.   (read-mail-from-file-to-boxes (text-string (get-port-target filename))))
  36.  
  37. (defun read-mail-from-file-to-boxes (file)
  38.   (with-open-file (in file '(in))
  39.     (do ((mail (ncons nil))
  40.      (system-type (send (send (send in :truename) :host) :system-type))
  41.      (message))
  42.     (())
  43.       (setq message (read-one-message in '*EOF* system-type))
  44.       (if (eq message '*EOF*)
  45.       (return (simple-make-box (cdr mail))))
  46.       (setq message (make-box message))
  47.       (tell message :set-display-style ':shrunk)
  48.       (nconc mail (ncons message)))))
  49.  
  50. (defun read-one-message (stream eof-option system-type)
  51.   (selectq system-type
  52.     (:tops-20 (read-one-twenex-message stream eof-option))
  53.     (:its (read-one-its-message stream eof-option))
  54.     (:otherwise (ferror "Can't yet read mail from a ~A site" system-type))))
  55.  
  56.  
  57. (defun read-one-twenex-message (stream &optional (eof-option nil))
  58.   (let ((info (readline stream eof-option)))
  59.     (if (equal info eof-option)
  60.     eof-option
  61.     (let* ((ibase 10.)
  62.            (index-start (+ 1 (string-search #/, info)))
  63.            (index-limit (string-search #/; info index-start))
  64.            (length (with-input-from-string (stream info index-start index-limit)
  65.              (read stream))))
  66.       (do* ((line (tell stream :line-in) (tell stream :line-in))
  67.         (count (string-length line)
  68.                (+ 2 count (string-length line)))
  69.         (message (ncons nil)))
  70.            ((eq line '*EOF*)
  71.         (if (not (equal '(nil) message))
  72.             message
  73.             line))
  74.         (if (> count length)
  75.         (let ((diff (- count length))
  76.               (slenm1 (1-  (string-length line))))
  77.           (send stream ':untyi #\return)
  78.           (dotimes (i diff)
  79.             (send stream ':untyi (aref line (- slenm1 i))))
  80.           (setq line (nsubstring line 0 (- (1+ slenm1) diff)))))
  81.         (nconc message (ncons (ncons (quote-any-funnies line))))
  82.         (if (>= count (- length 2))
  83.         (return (cdr message))))))))
  84.  
  85.  
  86. (defun read-one-its-message (stream &optional (eof-option nil))
  87.   (loop for line = (readline stream t) then (readline stream t)
  88.     collecting (ncons (quote-any-funnies line)) into list
  89.     until (or (not (stringp line)) (string-equal "" line))
  90.     finally (return (if (stringp line) list eof-option))))
  91.  
  92.  
  93. ;takes a list of boxes (or chas) and returns a box containing
  94. ;those actual objects.
  95. (defun simple-make-box (list)
  96.   (let* ((result (make-box '()))
  97.      (row (tell result :row-at-row-no 0)))
  98.     (do ((list list (cdr list)))
  99.     ((null list) result)
  100.       (tell row :append-cha (car list)))))
  101.  
  102. (DEFUN USER-MAIL-FILE ()
  103.   (LET ((FILE))
  104.     (ZWEI:VIEW-MAIL-INTERNAL #'(LAMBDA (U) (SETQ FILE U)))
  105.     FILE))
  106.  
  107. ;Currently the quoting code in boxer is broken so we must remove all bad chars.
  108. (defun quote-any-funnies (string)
  109.   (loop for place = (string-search-set *boxer-stream-special-characters* string)
  110.         then (string-search-set *boxer-stream-special-characters* string)
  111.     until (null place)
  112.     do (aset #/! string place)
  113.     finally (return string)))
  114.  
  115. ;  (if (null (string-search-set *boxer-stream-special-characters* string))
  116. ;      string
  117. ;      (let ((length (string-length string)))
  118. ;    (do ((new-string (MAKE-ARRAY 100 ':TYPE 'ART-STRING ':LEADER-LIST '(0)))
  119. ;         (index 0 (1+ index)))
  120. ;        ((= length index) new-string)
  121. ;      (if (string-search-set *boxer-stream-special-characters*
  122. ;                 (aref string index))
  123. ;          (array-push-extend new-string #/))
  124. ;      (array-push-extend new-string (aref string index))))))
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.